home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / BGIDEMO.ZIP / ARTY.PAS next >
Pascal/Delphi Source File  |  1992-10-27  |  9KB  |  380 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Art Demo Program                       }
  4. {   Copyright (c) 1992 by Borland International  }
  5. {                                                }
  6. {************************************************}
  7.  
  8. program Arty;
  9.  
  10. {
  11.   This program is a demonstration of the Borland Graphics Interface (BGI)
  12.  
  13.   Runtime Commands for ARTY
  14.   -------------------------
  15.   <B>   - changes background color
  16.   <C>   - changes drawcolor
  17.   <ESC> - exits program
  18.   Any other key pauses, then regenerates the drawing
  19.  
  20.   Note: If a /H command-line parameter is specified, the highest
  21.         resolution mode will be used (if possible).
  22. }
  23.  
  24. uses
  25.   Crt, Graph;
  26.  
  27. const
  28.    Memory  = 100;
  29.    Windows =   4;
  30.  
  31. type
  32.   ResolutionPreference = (Lower, Higher);
  33.   ColorList = array [1..Windows] of integer;
  34.  
  35. var
  36.   Xmax,
  37.   Ymax,
  38.   ViewXmax,
  39.   ViewYmax : integer;
  40.  
  41.   Line:  array [1..Memory] of record
  42.                                 LX1,LY1: integer;
  43.                                 LX2,LY2: integer;
  44.                                 LColor : ColorList;
  45.                               end;
  46.   X1,X2,Y1,Y2,
  47.   CurrentLine,
  48.   ColorCount,
  49.   IncrementCount,
  50.   DeltaX1,DeltaY1,DeltaX2,DeltaY2: integer;
  51.   Colors: ColorList;
  52.   Ch: char;
  53.   BackColor:integer;
  54.   GraphDriver, GraphMode : integer;
  55.   MaxColors : word;
  56.   MaxDelta : integer;
  57.   ChangeColors: Boolean;
  58.  
  59. procedure Frame;
  60. begin
  61.   SetViewPort(0, 0, Xmax, Ymax-(TextHeight('M')+4)-1,ClipOn);
  62.   SetColor(MaxColors);
  63.   Rectangle(0, 0, Xmax-1, (Ymax-(TextHeight('M')+4)-1)-1);
  64.   SetViewPort(1, 1, Xmax-2, (Ymax-(TextHeight('M')+4)-1)-2,ClipOn);
  65. end  { Frame };
  66.  
  67. procedure FullPort;
  68. { Set the view port to the entire screen }
  69. begin
  70.   SetViewPort(0, 0, Xmax, Ymax, ClipOn);
  71. end; { FullPort }
  72.  
  73. procedure MessageFrame(Msg:string);
  74. begin
  75.   FullPort;
  76.   SetColor(MaxColors);
  77.   SetTextStyle(DefaultFont, HorizDir, 1);
  78.   SetTextJustify(CenterText, TopText);
  79.   SetLineStyle(SolidLn, 0, NormWidth);
  80.   SetFillStyle(EmptyFill, 0);
  81.   Bar(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
  82.   Rectangle(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
  83.   OutTextXY(Xmax div 2, Ymax-(TextHeight('M')+2), Msg);
  84.   { Go back to the main window }
  85.   Frame;
  86. end  { MessageFrame };
  87.  
  88. procedure WaitToGo;
  89. var
  90.   Ch : char;
  91. begin
  92.   MessageFrame('Press any key to continue... Esc aborts');
  93.   repeat until KeyPressed;
  94.   Ch := ReadKey;
  95.   if Ch = #27 then begin
  96.       CloseGraph;
  97.       Writeln('All done.');
  98.       Halt(1);
  99.     end
  100.   else
  101.     ClearViewPort;
  102.   MessageFrame('Press a key to stop action, Esc quits.');
  103. end; { WaitToGo }
  104.  
  105. procedure TestGraphError(GraphErr: integer);
  106. begin
  107.   if GraphErr <> grOk then begin
  108.     Writeln('Graphics error: ', GraphErrorMsg(GraphErr));
  109.     repeat until keypressed;
  110.     ch := readkey;
  111.     Halt(1);
  112.   end;
  113. end;
  114.  
  115. procedure Init;
  116. var
  117.   Err, I: integer;
  118.   StartX, StartY: integer;
  119.   Resolution: ResolutionPreference;
  120.   s: string;
  121. begin
  122.   Resolution := Lower;
  123.   if paramcount > 0 then begin
  124.     s := paramstr(1);
  125.     if s[1] = '/' then
  126.       if upcase(s[2]) = 'H' then
  127.         Resolution := Higher;
  128.   end;
  129.  
  130.   CurrentLine    := 1;
  131.   ColorCount     := 0;
  132.   IncrementCount := 0;
  133.   Ch := ' ';
  134.   GraphDriver := Detect;
  135.   DetectGraph(GraphDriver, GraphMode);
  136.   TestGraphError(GraphResult);
  137.   case GraphDriver of
  138.     CGA        : begin
  139.                    MaxDelta := 7;
  140.                    GraphDriver := CGA;
  141.                    GraphMode := CGAC1;
  142.                  end;
  143.  
  144.     MCGA       : begin
  145.                    MaxDelta := 7;
  146.                    case GraphMode of
  147.                      MCGAMed, MCGAHi: GraphMode := MCGAC1;
  148.                    end;
  149.                  end;
  150.  
  151.     EGA         : begin
  152.                     MaxDelta := 16;
  153.                     If Resolution = Lower then
  154.                       GraphMode := EGALo
  155.                     else
  156.                       GraphMode := EGAHi;
  157.                   end;
  158.  
  159.     EGA64       : begin
  160.                     MaxDelta := 16;
  161.                     If Resolution = Lower then
  162.                       GraphMode := EGA64Lo
  163.                     else
  164.                       GraphMode := EGA64Hi;
  165.                   end;
  166.  
  167.      HercMono   : MaxDelta := 16;
  168.      EGAMono    : MaxDelta := 16;
  169.      PC3270     : begin
  170.                    MaxDelta := 7;
  171.                    GraphDriver := CGA;
  172.                    GraphMode := CGAC1;
  173.                  end;
  174.  
  175.  
  176.      ATT400     : case GraphMode of
  177.                     ATT400C1,
  178.                     ATT400C2,
  179.                     ATT400Med,
  180.                     ATT400Hi  :
  181.                       begin
  182.                         MaxDelta := 7;
  183.                         GraphMode := ATT400C1;
  184.                       end;
  185.                   end;
  186.  
  187.      VGA         : begin
  188.                      MaxDelta := 16;
  189.                    end;
  190.   end;
  191.   InitGraph(GraphDriver, GraphMode, '');
  192.   TestGraphError(GraphResult);
  193.   SetTextStyle(DefaultFont, HorizDir, 1);
  194.   SetTextJustify(CenterText, TopText);
  195.  
  196.   MaxColors := GetMaxColor;
  197.   BackColor := 0;
  198.   ChangeColors := TRUE;
  199.   Xmax := GetMaxX;
  200.   Ymax := GetMaxY;
  201.   ViewXmax := Xmax-2;
  202.   ViewYmax := (Ymax-(TextHeight('M')+4)-1)-2;
  203.   StartX := Xmax div 2;
  204.   StartY := Ymax div 2;
  205.   for I := 1 to Memory do with Line[I] do begin
  206.       LX1 := StartX; LX2 := StartX;
  207.       LY1 := StartY; LY2 := StartY;
  208.     end;
  209.  
  210.    X1 := StartX;
  211.    X2 := StartX;
  212.    Y1 := StartY;
  213.    Y2 := StartY;
  214. end; {init}
  215.  
  216. procedure AdjustX(var X,DeltaX: integer);
  217. var
  218.   TestX: integer;
  219. begin
  220.   TestX := X+DeltaX;
  221.   if (TestX<1) or (TestX>ViewXmax) then begin
  222.     TestX := X;
  223.     DeltaX := -DeltaX;
  224.   end;
  225.   X := TestX;
  226. end;
  227.  
  228. procedure AdjustY(var Y,DeltaY: integer);
  229. var
  230.   TestY: integer;
  231. begin
  232.   TestY := Y+DeltaY;
  233.   if (TestY<1) or (TestY>ViewYmax) then begin
  234.     TestY := Y;
  235.     DeltaY := -DeltaY;
  236.   end;
  237.   Y := TestY;
  238. end;
  239.  
  240. procedure SelectNewColors;
  241. begin
  242.   if not ChangeColors then exit;
  243.   Colors[1] := Random(MaxColors)+1;
  244.   Colors[2] := Random(MaxColors)+1;
  245.   Colors[3] := Random(MaxColors)+1;
  246.   Colors[4] := Random(MaxColors)+1;
  247.   ColorCount := 3*(1+Random(5));
  248. end;
  249.  
  250. procedure SelectNewDeltaValues;
  251. begin
  252.   DeltaX1 := Random(MaxDelta)-(MaxDelta Div 2);
  253.   DeltaX2 := Random(MaxDelta)-(MaxDelta Div 2);
  254.   DeltaY1 := Random(MaxDelta)-(MaxDelta Div 2);
  255.   DeltaY2 := Random(MaxDelta)-(MaxDelta Div 2);
  256.   IncrementCount := 2*(1+Random(4));
  257. end;
  258.  
  259.  
  260. procedure SaveCurrentLine(CurrentColors: ColorList);
  261. begin
  262.   with Line[CurrentLine] do
  263.   begin
  264.     LX1 := X1;
  265.     LY1 := Y1;
  266.     LX2 := X2;
  267.     LY2 := Y2;
  268.     LColor := CurrentColors;
  269.   end;
  270. end;
  271.  
  272. procedure Draw(x1,y1,x2,y2,color:word);
  273. begin
  274.   SetColor(color);
  275.   Graph.Line(x1,y1,x2,y2);
  276. end;
  277.  
  278. procedure Regenerate;
  279. var
  280.   I: integer;
  281. begin
  282.   Frame;
  283.   for I := 1 to Memory do with Line[I] do begin
  284.     Draw(LX1,LY1,LX2,LY2,LColor[1]);
  285.     Draw(ViewXmax-LX1,LY1,ViewXmax-LX2,LY2,LColor[2]);
  286.     Draw(LX1,ViewYmax-LY1,LX2,ViewYmax-LY2,LColor[3]);
  287.     Draw(ViewXmax-LX1,ViewYmax-LY1,ViewXmax-LX2,ViewYmax-LY2,LColor[4]);
  288.   end;
  289.   WaitToGo;
  290.   Frame;
  291. end;
  292.  
  293. procedure Updateline;
  294. begin
  295.   Inc(CurrentLine);
  296.   if CurrentLine > Memory then CurrentLine := 1;
  297.   Dec(ColorCount);
  298.   Dec(IncrementCount);
  299. end;
  300.  
  301. procedure CheckForUserInput;
  302. begin
  303.   if KeyPressed then begin
  304.     Ch := ReadKey;
  305.     if Upcase(Ch) = 'B' then begin
  306.       if BackColor > MaxColors then BackColor := 0 else Inc(BackColor);
  307.       SetBkColor(BackColor);
  308.     end
  309.     else
  310.     if Upcase(Ch) = 'C' then begin
  311.       if ChangeColors then ChangeColors := FALSE else ChangeColors := TRUE;
  312.       ColorCount := 0;
  313.     end
  314.     else if Ch<>#27 then Regenerate;
  315.   end;
  316. end;
  317.  
  318. procedure DrawCurrentLine;
  319. var c1,c2,c3,c4: integer;
  320. begin
  321.   c1 := Colors[1];
  322.   c2 := Colors[2];
  323.   c3 := Colors[3];
  324.   c4 := Colors[4];
  325.   if MaxColors = 1 then begin
  326.     c2 := c1; c3 := c1; c4 := c1;
  327.   end;
  328.  
  329.   Draw(X1,Y1,X2,Y2,c1);
  330.   Draw(ViewXmax-X1,Y1,ViewXmax-X2,Y2,c2);
  331.   Draw(X1,ViewYmax-Y1,X2,ViewYmax-Y2,c3);
  332.   if MaxColors = 3 then c4 := Random(3)+1; { alternate colors }
  333.   Draw(ViewXmax-X1,ViewYmax-Y1,ViewXmax-X2,ViewYmax-Y2,c4);
  334.   SaveCurrentLine(Colors);
  335. end;
  336.  
  337. procedure EraseCurrentLine;
  338. begin
  339.   with Line[CurrentLine] do begin
  340.     Draw(LX1,LY1,LX2,LY2,0);
  341.     Draw(ViewXmax-LX1,LY1,ViewXmax-LX2,LY2,0);
  342.     Draw(LX1,ViewYmax-LY1,LX2,ViewYmax-LY2,0);
  343.     Draw(ViewXmax-LX1,ViewYmax-LY1,ViewXmax-LX2,ViewYmax-LY2,0);
  344.   end;
  345. end;
  346.  
  347.  
  348. procedure DoArt;
  349. begin
  350.   SelectNewColors;
  351.   repeat
  352.     EraseCurrentLine;
  353.     if ColorCount = 0 then SelectNewColors;
  354.  
  355.     if IncrementCount=0 then SelectNewDeltaValues;
  356.  
  357.     AdjustX(X1,DeltaX1); AdjustX(X2,DeltaX2);
  358.     AdjustY(Y1,DeltaY1); AdjustY(Y2,DeltaY2);
  359.  
  360.     if Random(5)=3 then begin
  361.       x1 := (x1+x2) div 2; { shorten the lines }
  362.       y2 := (y1+y2) div 2;
  363.     end;
  364.  
  365.     DrawCurrentLine;
  366.     Updateline;
  367.     CheckForUserInput;
  368.   until Ch=#27;
  369. end;
  370.  
  371. begin
  372.    Init;
  373.    Frame;
  374.    MessageFrame('Press a key to stop action, Esc quits.');
  375.    DoArt;
  376.    CloseGraph;
  377.    RestoreCrtMode;
  378.    Writeln('The End.');
  379. end.
  380.